home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / ENTRY.SWG / 0018_Date Input Routine.pas < prev    next >
Pascal/Delphi Source File  |  1995-03-03  |  11KB  |  392 lines
  1. { This is a big one... This is an (hopefully) error free, full featured, date
  2. input routine. It accepts all known editing keys (such as left, right, del, bs
  3. etc,etc,etc...) and validates the inserted date. Well, the parameters are:
  4.  
  5.           data(x,y:integer;ct:boolean; var inp:string; var ret:integer);
  6.  
  7.           (x,y) - coordinates of input location;
  8.           ct    - is insert on (true) or off (false);
  9.           inp   - where the new date will be inserted;
  10.           ret   - return code. 1 means up was pressed, 2 means down pressed;
  11.                   0 means esc was pressed. Any of these abort date entry,
  12.                   although that can be easily fixed by deactivating their
  13.                   entries in the datainput procedure;
  14.  
  15. Dates get out in the European DD/MM/YY format. This only afects the validation,
  16. so if you want to change it, change the order of x1, x2 and x3 in vali_date to
  17. suit your needs. For instance, to get the format MM/DD/YY, change all x1 in the
  18. val functions to x2, and all x2 to x1. ONLY IN THE VAL, in the beggining of the
  19. vali_date procedure.
  20.  
  21. Portuguese Freeware, 1994, Luis Evaristo Fonseca Thunderball Software Inc.
  22. }
  23.  
  24. unit dateinp;
  25.  
  26. interface    
  27.  
  28. uses crt,top;
  29.  
  30. const
  31.     BS        =   8;
  32.     TAB       =   9;
  33.     CR        =  13;
  34.     CTRLT     =  20;
  35.     CTRLY     =  25;
  36.     ESC       =  27;
  37.     HOME      = 327;
  38.     UP        = 328;
  39.     ENDK    
  40.     DOWN      = 336;
  41.     LEFT      = 331;
  42.     RIGHT     = 333;
  43.     INS       = 338;
  44.     DEL       = 339;
  45.     CTRLLEFT  = 371;
  46.     CTRLRIGHT = 372;
  47.     ONLYNUM=['0'..'9'];
  48.  
  49. procedure data(x,y:integer;ct:boolean; var inp:string; var ret:integer);
  50.  
  51. IMPLEMENTATION
  52.  
  53. { lê tecla premida }
  54. function getkey : word;
  55. var
  56.     ch : char;
  57. begin
  58.     ch := readkey;
  59.     if ch=#0 then 
  60.         getkey := ord(readkey)+256
  61.     else
  62.         getkey := ord(ch);   
  63. end;
  64.  
  65. { escreve a string no écran }
  66. procedure writestr(x,y:integer;inp:string;var x1:integer);
  67. var aux,conta:integer;
  68. begin
  69.     gotoxy(x,y);
  70.     write('  /  /  ');
  71.     gotoxy(x,y);
  72.     aux:=x;
  73.     for conta:=1 to ord(inp[0]) do
  74.     begin
  75.         case conta of
  76.             1,2:begin
  77.                     gotoxy(x+conta-1,y);
  78.                     write(inp[conta]);
  79.                 end;
  80.             3,4:begin
  81.                     gotoxy(x+conta,y);
  82.                     write(inp[conta]);
  83.                 end;
  84.             5,6:begin
  85.                     gotoxy(x+conta+1,y);
  86.                     write(inp[conta]);
  87.                 end;
  88.         end;
  89.     end;
  90.     gotoxy(x1,y);
  91. end;
  92.  
  93. { salta para a primeira posiçäo de cursor válida, actualiza écran }
  94. procedure homekey(x,y:integer; var x1,posic:integer);
  95. begin
  96.     x1:=x;
  97.     posic:=1;
  98.     gotoxy(x1,y);
  99. end;
  100.  
  101. { salta para a última posiç╞o de cursor utilizada, actualiza écran }
  102. procedure endkey(inp:string;x,y:integer;var x1,posic:integer);
  103. begin
  104.     case length(inp) of
  105.         1:x1:=x+1;
  106.         2:x1:=x+3;
  107.         3:x1:=x+4;
  108.         4:x1:=x+6;
  109.         5:x1:=x+7;
  110.         6:x1:=x+7;
  111.     end;
  112.     posic:=length(inp)+1;
  113.     if posic>6 then
  114.         posic:=6;
  115.     gotoxy(x1,y);
  116. end;
  117.  
  118. { move o cursor uma casa para a esquerda, actualiza écran, näo ultrapassa o }
  119. { limite máximo de cursor à esquerda }
  120. procedure leftkey(x,y:integer; var x1,posic:integer);
  121. begin
  122.     x1:=x1-1;
  123.     posic:=posic-1;
  124.     if (x1=x+2) or (x1=x+5) then
  125.         x1:=x1-1;
  126.     if x1-x<0 then
  127.     begin
  128.         x1:=x1+1;
  129.         posic:=posic+1;
  130.     end;
  131.     gotoxy(x1,y);
  132. end;
  133.  
  134. { move o cursor uma casa para a direita, actualiza écran, n╞o ultrapassa a }
  135. { posiç╞o do último caracter escrito mais uma posiç╞o }
  136. procedure rightkey(x,y:integer; inp:string; var x1,posic:integer);
  137. begin
  138.     x1:=x1+1;
  139.     posic:=posic+1;
  140.     if (x1=x+2)  or (x1=x+5) then
  141.         x1:=x1+1;
  142.     if (length(inp)+1<posic) or (x1>x+7) then
  143.     begin
  144.         x1:=x1-1;
  145.         posic:=posic-1;
  146.     end;
  147.     gotoxy(x1,y);
  148. end;
  149.  
  150. { move o cursor para a primeira letra da palavra, ou (caso }
  151. { o cursor n╞o se encontre sobre nenhuma palavra, a próxima }
  152. procedure ctrll(x,y:integer; inp:string; var x1,posic:integer);
  153. begin
  154.     if posic<4 then
  155.     begin
  156.         posic:=1;
  157.         x1:=x;
  158.     end
  159.     else
  160.     begin
  161.         posic:=3;
  162.         x1:=x+3;
  163.     end;
  164.     gotoxy(x1,y);
  165. end;
  166.  
  167. { move o cursor para a primeira letra da palavra seguinte }
  168. procedure ctrlr(x,y:integer; inp:string; var x1,posic:integer);
  169. begin
  170.     case posic of
  171.         1,2:if length(inp)>1 then
  172.             begin
  173.                 posic:=3;
  174.                 x1:=x+3;
  175.             end;
  176.         3,4:if length(inp)>3 then
  177.             begin
  178.                 posic:=5;
  179.                 x1:=x+6;
  180.             end;
  181.     end;
  182.     gotoxy(x1,y);
  183. end;
  184.  
  185. { apaga tudo o que está escrito, actualiza string e ecran }
  186. procedure ctrl_y(x,y:integer; var x1,posic:integer; var inp:string);
  187. begin
  188.     x1:=x;
  189.     posic:=1;
  190.     inp:='';
  191.     writestr(x,y,inp,x1);
  192. end;
  193.  
  194. { apaga tudo o que está escrito à direita do cursor, actualiza string e ecran }
  195. procedure ctrl_t(x,y:integer; var x1,posic:integer; var inp:string);
  196. var conta:integer;
  197. begin
  198.     if length(inp)>posic then
  199.         for conta:=posic to length(inp) do
  200.             delete(inp,posic,1);
  201.     writestr(x,y,inp,x1);
  202. end;
  203.  
  204. { liga / desliga o modo de inserçäo "overwrite" (cursor em bloco) ou normal }
  205. procedure inskey(var ct:boolean);
  206. begin
  207.     if ct=true then
  208.     begin
  209.         bigcursor;
  210.         ct:=false
  211.     end
  212.     else
  213.     begin
  214.         linecursor;
  215.         ct:=true;
  216.     end;
  217. end;
  218.  
  219. { apaga o caracter à direita na string, actualiza écran }
  220. procedure delk(x,y:integer;var x1,posic:integer;var inp:string);
  221. begin
  222.     if length(inp)>=posic then
  223.         delete(inp,posic,1);
  224.     writestr(x,y,inp,x1);
  225. end;
  226.  
  227. { apaga o caracter à esquerda na string, actualiza écran, n╞o passa o }
  228. { limite máximo à esquerda }
  229. procedure bsk(x,y:integer;var x1,posic:integer;var inp:string);
  230. begin
  231.     if x1-1>=x then
  232.     begin
  233.          delete(inp,posic-1,1);
  234.          if (posic in [3,5]) then
  235.              x1:=x1-2
  236.          else
  237.              x1:=x1-1;
  238.          posic:=posic-1;
  239.          writestr(x,y,inp,x1);
  240.     end;
  241. end;
  242.  
  243. procedure tabkey(x,y:integer;ct:boolean;var x1,posic:integer;var inp:string);
  244. var conta:integer;
  245. begin
  246.     case posic of
  247.         1,2:if length(inp)>1 then
  248.             begin
  249.                 posic:=3;
  250.                 x1:=x+3;
  251.             end;
  252.         3,4:if length(inp)>3 then
  253.             begin
  254.                 posic:=5;
  255.                 x1:=x+6;
  256.             end;
  257.     end;
  258.     gotoxy(x1,y);
  259. end;
  260.  
  261. procedure datainput(x,y:integer;var inp:string;var ct:boolean;var ret:integer);
  262. var x1,conta,posic:integer;
  263.     c:word;
  264. begin
  265.     x1:=x;
  266.     posic:=1;
  267.     gotoxy(x1,y);
  268.     c:=100;
  269.     while (c<>CR) do
  270.     begin
  271.         c:=getkey;
  272.         if (c>28) and (c<256) and (chr(c) in onlynum) then
  273.         begin
  274.             if (x1=x+1) or (x1=x+4) then
  275.                 inc(x1);
  276.             if ct=true then
  277.             begin
  278.                 if length(inp)+1<=6 then
  279.                 begin
  280.                     insert(chr(c),inp,posic);
  281.                     if posic+1<=6 then
  282.                     begin
  283.                         inc(posic);
  284.                         inc(x1);
  285.                     end;
  286.                 end
  287.             end
  288.             else
  289.             begin
  290.                 if (posic=length(inp)+1) and (length(inp)<6) then
  291.                     inp[0]:=chr(ord(inp[0])+1);
  292.                 inp[posic]:=chr(c);
  293.                 if posic<6 then
  294.                 begin
  295.                     inc(x1);
  296.                     inc(posic);
  297.                 end;
  298.             end;
  299.         end
  300.         else
  301.         begin
  302.             case c of
  303.                 BS:bsk(x,y,x1,posic,inp);
  304.                 HOME:homekey(x,y,x1,posic);
  305.                 ENDK:endkey(inp,x,y,x1,posic);
  306.                 LEFT:leftkey(x,y,x1,posic);
  307.                 RIGHT:rightkey(x,y,inp,x1,posic);
  308.                 CTRLLEFT:ctrll(x,y,inp,x1,posic);
  309.                 CTRLRIGHT:ctrlr(x,y,inp,x1,posic);
  310.                 INS:inskey(ct);
  311.                 DEL:delk(x,y,x1,posic,inp);
  312.                 TAB:tabkey(x,y,ct,x1,posic,inp);
  313.                 CTRLY:ctrl_y(x,y,x1,posic,inp);
  314.                 CTRLT:ctrl_t(x,y,x1,posic,inp);
  315.                 UP:begin
  316.                         ret:=1;
  317.                         exit;
  318.                    end;
  319.                 DOWN:begin
  320.                         ret:=2;
  321.                         exit;
  322.                      end;
  323.                 ESC:begin
  324.                         ret:=0;
  325.                         exit;
  326.                     end;
  327.             end;
  328.         end;
  329.         writestr(x,y,inp,x1);
  330.     end;
  331. end;
  332.  
  333. function vali_date(inp:string):boolean;
  334. var x1,x2,x3,code:integer;
  335. begin
  336.     val(inp[1]+inp[2],x1,code);
  337.     val(inp[3]+inp[4],x2,code);
  338.     val(inp[5]+inp[6],x3,code);
  339.     if (inp<>'') then
  340.     begin
  341.         if (x2>0) and (x2<13) then
  342.         begin
  343.             case x2 of
  344.                  1,3,5,7,8,10,12:if (x1>0) and (x1<32) then
  345.                                      vali_date:=true
  346.                                  else
  347.                                      vali_date:=false;
  348.                  4,6,9,11       :if (x1>0) and (x1<31) then
  349.                                      vali_date:=true
  350.                                  else
  351.                                      vali_date:=false;
  352.                  2              :if (x1>0) and (x1<30) then
  353.                                  begin
  354.                                      if (x3+1900) mod 4 <> 0 then
  355.                                      begin
  356.                                          if x1<29 then
  357.                                              vali_date:=true
  358.                                          else
  359.                                              vali_date:=false;
  360.                                      end
  361.                                      else
  362.                                          if x1<30 then
  363.                                              vali_date:=true
  364.                                          else
  365.                                              vali_date:=false;
  366.                                  end
  367.                                  else
  368.                                      vali_date:=false;
  369.              end;
  370.         end
  371.         else
  372.              vali_date:=false;
  373.     end
  374.     else
  375.         vali_date:=true;
  376. end;
  377.  
  378. procedure data(x,y:integer;ct:boolean;var inp:string; var ret:integer);
  379. var test:boolean;
  380. begin
  381.     gotoxy(x,y);
  382.     test:=false;
  383.     while test=false do
  384.     begin
  385.           datainput(x,y,inp,ct,ret);
  386.           test:=vali_date(inp);
  387.     end;
  388. end;
  389.  
  390. begin
  391. end.
  392.